{***************************************************************
    SpyGestion  Copyright (C) 2008 Christophe KOALI <nature2gas@gmail.com>
    
    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.
    
    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
    
    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
    
****************************************************************}
unit modTunnelGestion;

interface

uses Classes,
     ESBDates,
     SysUtils,
     sFonctionsChaines,
     ZlibEx,
     modMimeType,
     modHttpProtocolStatusCode,
     WSocket,
     HttpProt,
     modTunnelSessionId,
     
     modTemplateMotor,
     modTunnelTemplate,

     WSocketS;


type

    TTunnelHttpState = (hcAttenteFirstLineHeader, hcAttenteFinHeader, hcAttenteFinDonneesPoste, hcForceClose);


  { TClientThread is our worker thread class. Each time a client connect, a }
  { new TClientThread is instanciated and client socket attached to it so   }
  { events are processed in the thread's context.                           }
  { Remember that multithreading requires synchronization, specially when   }
  { updating GUI or accessing shared data.                                  }
  { TClientThread uses OnDisplay event to display data on the application   }
  { main form. Synchronization is automatically done.                       }
  TTunnelClientThread = class(TThread)
  private
      FWSocket        : TWSocket;             { Reference to client socket  }

      {$IFDEF DEBUG}
        FMsg            : String;               { Message to be displayed     }
        FOnDisplay      : TsfcProcStatus;         { Event variable              }
      {$ENDIF}

      FThreadAttached : Boolean;              { TRUE once socket attached   }
      procedure DisplayMsg;                   { Synchronized procedure      }
  public
      TunnelSessionId: TCollectionTunnelSessionId;
      DossierTunnel  : string;


      procedure Execute; override;            { Main method                 }

      {$IFDEF DEBUG}
      procedure Display(const Msg : String);  { Takes care of synchroniz.   }
      {$ENDIF}

  published
      property WSocket   :      TWSocket     read  FWSocket
                                             write FWSocket;
      property ThreadAttached : Boolean      read  FThreadAttached
                                             write FThreadAttached;

      {$IFDEF DEBUG}
      property OnDisplay :      TsfcProcStatus read  FOnDisplay
                                               write FOnDisplay;
      {$ENDIF}
  end;



    TTunnelHttpConnection = class(TWSocketClient)
    protected
        //FRequestHeader         : TStringList;
        FState                 : TTunnelHttpState;

        // tampon de lecture
        FBuffer                : string;

        // première ligne de la requete
        FMethod                : String;
        FVersion               : String;
        FPathRequest           : String;

        // données postées par le client
        FPostedData            : string;

        // autres champs de la requete
        FRequestContentLength  : Integer;
        FRequestContentType    : String;
        FRequestAccept         : String;
        FRequestReferer        : String;
        FRequestAcceptLanguage : String;
        FRequestAcceptEncoding : String;
        FRequestAcceptEncodingGZip: boolean;
        FRequestAcceptEncodingDeflate: boolean;

        FRequestUserAgent      : String;
        FRequestAuth           : String;        {DAVID}
        FRequestCookies        : String;
        FRequestHost           : String;
        FRequestHostName       : String;        {DAVID}
        FRequestHostPort       : String;        {DAVID}
        FRequestConnection     : String;





        // propre procédure de reception de données

        procedure TraitementHeaderFromBuffer;

        // lorsque l'header a été lu
        procedure TriggerOnHeaderLu;

        // Lorsque le client a effectué une requete (header + données postées si il y en a)
        procedure TriggerClientRequete;


        procedure InitRequestInfos;

        procedure SendStream(stream: TStream);


        procedure TraitementRequete;

    public
        ClientThread: TTunnelClientThread;
        
        kOnRequest             : TNotifyEvent;
        ReponseContentType     : string;
        ReponseAdditionalHeader: string;  // pour les cookies

        SocketRelay: THttpCli;
        SessionId   : PTunnelSessionId;


        SockMotorTemplate: TTemplatePage;


        
        function GetRequestCookie(Nom: string): string;
        function GetRequestPOST(Nom: string): string;


        function TunnelGetFullFile(RelativePath: string): string;
        procedure TunnelSendFile(RelativePath: string);


        property RequestMethod          : String      read  FMethod;
        property RequestVersion         : String      read  FVersion;
        property RequestPath            : String      read  FPathRequest;
        property RequestPostedData      : String      read  FPostedData;


        { All RequestXXX are header fields from request header }
        property RequestContentLength  : Integer     read  FRequestContentLength;
        property RequestContentType    : String      read  FRequestContentType;
        property RequestAccept         : String      read  FRequestAccept;
        property RequestReferer        : String      read  FRequestReferer;
        property RequestAcceptLanguage : String      read  FRequestAcceptLanguage;
        property RequestAcceptEncoding : String      read  FRequestAcceptEncoding;
        property RequestUserAgent      : String      read  FRequestUserAgent;
        property RequestAuth           : String      read  FRequestAuth; {DAVID}
        property RequestCookies        : String      read  FRequestCookies;
        property RequestHost           : String      read  FRequestHost;
        property RequestHostName       : String      read  FRequestHostName;    {DAVID}
        property RequestHostPort       : String      read  FRequestHostPort;    {DAVID}
        property RequestConnection     : String      read  FRequestConnection;

        constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;

        procedure lOnClientDataAvailable(Sender: TObject; Error: Word);



        procedure SendPageWeb(sDataPageWeb: string; hStatusCode: integer = 200);
        procedure SendFile(Fichier: string; AutoAjustContentType: boolean);
        function GetBasicHeader(StatusCode: integer): string;

        procedure MakeErreur(StatusCode: integer);
        procedure MakeRedirection(Path: string);


        procedure SetCookie(Nom, Valeur: string; Expires: int64 = 0; Path: string = '');
        procedure AddHeaderLigne(Ligne: string);

    end;

    function tlgExtractLocation(s: TStrings): string;
    procedure tlgCopySocketHttpInfos(dst, src: THttpCli);

implementation


procedure TTunnelHttpConnection.TunnelSendFile(RelativePath: string);
var Fichier: string;
begin

    Fichier := TunnelGetFullFile(RelativePath);

    if Fichier = '' then begin
       MakeErreur(404);
       exit;
    end;

    SendFile(Fichier, true);
end;


function TTunnelHttpConnection.TunnelGetFullFile(RelativePath: string): string;
begin
    Result := '';

    if pos('..', RelativePath) > 0 then begin
       exit;
    end;

    Result := sfcFileGetFullDir(ClientThread.DossierTunnel, RelativePath);

    if pos(ClientThread.DossierTunnel, Result) < 1 then begin
       // on est descendu dans la racine...
       // impossible car on a interdit la chaine ".." mais bon, peut-être
       // le code hexadécimal a été utilisé
       Result := '';
       exit;
    end;

end;



procedure TTunnelHttpConnection.TraitementRequete;
label lSelectionPage, lSectionNoSession;
var sServiceDesire, sParams: string;
    xPos: integer;
    CurrDate: int64;
begin

   ClientThread.Display('Req: ' + RequestPath);

   SessionId := ClientThread.TunnelSessionId.Get_Pointeur(GetRequestCookie(TUNNEL_COOKIE_AUTH_SESSION_ID));


   sServiceDesire := '';
   sParams        := '';

   if length(RequestPath) > 4 then begin
      sServiceDesire := RequestPath;
      System.Delete(sServiceDesire, 1, 1);

      xPos := pos('/', sServiceDesire);
      if xPos > 1 then begin
         sParams := copy(sServiceDesire, xPos + 1, maxint);
         System.Delete(sServiceDesire, xPos, maxint);
      end;

   end;

   if SessionId = nil then begin
      // affiche la page de login
lSectionNoSession:
      xPos := 1;

      if SameText(sServiceDesire, 'relay') then begin
         //TunnelTraitement_RELAY(s, sParams);
         xPos := 0;

      end else if SameText(sServiceDesire, 'forum') then begin
         MakeRedirection('/');

      end else if SameText(sServiceDesire, 'robot') then begin
         MakeRedirection('/');

      end else if SameText(sServiceDesire, 'game') then begin
         MakeRedirection('/');

      end else if sServiceDesire <> '' then begin
         // dossier img ou css ou autres
         TunnelSendFile(RequestPath);
         xPos := 0;
      end;

      if xPos = 1 then begin

         if SockMotorTemplate = nil then begin
            SockMotorTemplate := TTemplatePage.Create;
         end;

         SockMotorTemplate.LoadFromFile(TunnelGetFullFile(TUNNEL_RELAY_FILE_LOGIN_PAGE));
         SockMotorTemplate.ConditionSet(TPL_COND_LOGINPAGE_PASSWORD_INVALID, 0);
         SockMotorTemplate.ProceedFinal;

         if SockMotorTemplate.DocumentOut <> '' then begin
            SendPageWeb(SockMotorTemplate.DocumentOut);
         end else begin
            MakeErreur(404);
         end;

         SockMotorTemplate.Free;
         SockMotorTemplate := nil;

      end;



    end;


   
end;
















procedure tlgCopySocketHttpInfos(dst, src: THttpCli);
begin
    dst.Agent          := src.Agent;
    dst.Accept         := src.Accept;
    dst.AcceptLanguage := src.AcceptLanguage;

    dst.Proxy          := src.Proxy;
    dst.ProxyPort      := src.ProxyPort;
    dst.ProxyUsername  := src.ProxyUsername;
    dst.ProxyPassword  := src.ProxyPassword;

    
    // fucking relocation
    // on est seulement un proxy
    dst.FollowRelocation  := false;
end;

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{*                                                                         *}
{*                          TClientThread                                  *}
{*                                                                         *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

{$IFDEF DEBUG}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This is our client worker thread main procedure. It is thread's code.     }
{ We have to attach client socket to this thread's context and then         }
{ process messages so that TWSocket events works.                           }
procedure TTunnelClientThread.Execute;
begin
    if not Assigned(WSocket) then
        Exit;

    { Attach client socket to this thread                                   }
    WSocket.ThreadAttach;

    { Signal main thread that we've attached socket to this thread          }
    ThreadAttached := TRUE;

    { Now let main thread continue starting the connection.                 }
    { This little avoid race condition.                                     }
    Sleep(1);

    { Then process messages until WM_QUIT message is posted.                }
    { TWSocket is event-driven. So even when used within a thread, we       }
    { have to have a "message pump". Any message pump will do and there     }
    { is one built in TWSocket, so use it !                                 }
    WSocket.MessageLoop;

    { Be sure to have main thread waiting for termination before terminating}
    Sleep(50);
    
    { Detach the hidden window from within the thread                       }
    WSocket.ThreadDetach;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This procedure is called from client thread and must display a message    }
{ on the GUI (main application form). As we are in a thread, we can't       }
{ simply call something that act on the GUI, we MUST use synchronize to ask }
{ main thread to update the GUI.                                            }
procedure TTunnelClientThread.Display(const Msg: String);
begin
    { Synchronized procedure have no parameter, we must use a variable      }
    FMsg := Msg;
    { Then synchronize the procedure (which will use FMsg)                  }
    Synchronize(DisplayMsg);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ Never call this procedure directly, always call Synchronize(DisplayMsg)   }
procedure TTunnelClientThread.DisplayMsg;
begin
    if Assigned(FOnDisplay) then
        FOnDisplay(FMsg);
end;

{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}







const
   CRLF = #$0D#$0A;

function tlgExtractLocation(s: TStrings): string;
var i: integer;
    Ligne, sKey: string;
    xPos: integer;
begin

    Result := '';
    
    if s.Count = 0 then exit;

    for i := 0 to s.Count - 1 do begin
       Ligne := s.Strings[i];
       xPos := pos(':', Ligne);

       if xPos = 0 then
          Continue;

       sKey := copy(Ligne, 1, xPos - 1);
       if SameText(sKey, 'Location') then begin
          Result := trim(copy(Ligne, xPos + 1, maxint));
          exit;
       end;
    end;

end;



function TTunnelHttpConnection.GetRequestPOST(Nom: string): string;
var xPos: integer;
    Key, Current, Buffer: string;
begin
    Result := '';
    Buffer := FPostedData;

    repeat
        xPos := pos('&', Buffer);

        if xPos < 1 then begin
           Current := Buffer;
           Buffer  := '';
        end else begin
           Current := copy(Buffer, 1, xPos - 1);
           System.Delete(Buffer, 1, xPos);
        end;

        xPos := pos('=', Current);
        if xPos = 0 then
           // impossible
           break;

        Key := copy(Current, 1, xPos - 1);
        System.Delete(Current, 1, xPos);

        if SameText(Key, Nom) then begin
           Result := Current;
           exit;
        end;

    until False;


end;


function TTunnelHttpConnection.GetRequestCookie(Nom: string): string;
var xPos: integer;
    Key, Current, Buffer: string;
begin
    Result := '';
    Buffer := FRequestCookies;

    repeat
        xPos := pos(';', Buffer);

        if xPos < 1 then begin
           Current := Buffer;
           Buffer  := '';
        end else begin
           Current := copy(Buffer, 1, xPos - 1);
           System.Delete(Buffer, 1, xPos);
        end;

        xPos := pos('=', Current);
        if xPos = 0 then
           // impossible
           break;

        Key := copy(Current, 1, xPos - 1);
        System.Delete(Current, 1, xPos);

        if SameText(Key, Nom) then begin
           Result := Current;
           exit;
        end;

    until False;

    
end;


procedure TTunnelHttpConnection.AddHeaderLigne(Ligne: string);
begin
    ReponseAdditionalHeader := ReponseAdditionalHeader + Ligne + CRLF;

end;

procedure TTunnelHttpConnection.SetCookie(Nom, Valeur: string; Expires: int64 = 0; Path: string = '');
var Ligne: string;
begin
    //Set-Cookie: AMA=1119036327; expires=Fri, 17-Jun-05 19:25:27 GMT; path=/

    Ligne := format('Set-Cookie: %s=%s', [Nom, Valeur]);

    if Expires > 0 then begin
       Ligne := Ligne + '; expires=' + ESBRFC1123_Date(0.0);
    end;

    if Path <> '' then begin
       Ligne := Ligne + '; path=' + Path;
    end;

    AddHeaderLigne(Ligne);

end;

procedure TTunnelHttpConnection.InitRequestInfos;
begin
        FMethod                := '';
        FVersion               := '';
        FPathRequest           := '';

        DateTimeToUnix(Now);


        // données postés par le client
        FPostedData            := '';

        FRequestContentLength  := 0;
        FRequestContentType    := '';
        FRequestAccept         := '';
        FRequestReferer        := '';
        FRequestAcceptLanguage := '';
        FRequestAcceptEncoding := '';
        FRequestUserAgent      := '';
        FRequestAuth           := '';
        FRequestCookies        := '';
        FRequestHost           := '';
        FRequestHostName       := '';
        FRequestHostPort       := '';
        FRequestConnection     := '';

        FRequestAcceptEncodingGZip    := false;
        FRequestAcceptEncodingDeflate := false;


        ReponseContentType := '';
        ReponseAdditionalHeader := '';

end;

procedure TTunnelHttpConnection.SendStream(stream: TStream);
const TAILLE_TAMPON = 4096;
var Tampon: string;
    NbLu: integer;
begin

     SetLength(Tampon, TAILLE_TAMPON);

     while (stream.Position < stream.Size) do begin

        NbLu := stream.Read(Tampon[1], TAILLE_TAMPON);

        if NbLu < TAILLE_TAMPON then begin
           System.Delete(Tampon, NbLu + 1, maxint);
           SendStr(Tampon);
           Sleep(1);
           break;
        end else begin
          SendStr(Tampon);
        end;

     end;

     Flush;

end;

procedure TTunnelHttpConnection.SendFile(Fichier: string; AutoAjustContentType: boolean);
label lSendFileNoCompression;
var FileExtension: string;
    bUseCompression: boolean;
    FIn: TFileStream;

    CompressionStream: TZCompressionStream;
    OutputStream: TMemoryStream;
begin

    if FileExists(Fichier) = false then begin
       // 404 not found
       MakeErreur(PROTOCOL_HTTP_ERREUR);
       exit;
    end;

    // http://www.utoronto.ca/webdocs/HTMLdocs/Book/Book-3ed/appb/mimetype.html
    FileExtension := ExtractFileExt(Fichier);
    if FileExtension <> '' then
       System.Delete(FileExtension, 1, 1);


    ReponseContentType := mtGetMimeTypeFromExtension(FileExtension, bUseCompression);

    if ReponseContentType = '' then begin
       // inconnu...
       ReponseContentType := 'application/octet-stream';
       bUseCompression := false;
    end;

    try
      FIn := TFileStream.Create(Fichier, fmOpenRead);
    except
      FIn := nil;
    end;

    if FIn = nil then begin
       MakeErreur(PROTOCOL_HTTP_INTERNAL_ERROR);
       exit;
    end;


    // 1 Mo = 1048576
    if FIn.Size > 3145728 then begin
       // pas de compression obligatoirement
       // le fichier est trop gros pour l'être
       bUseCompression := false;
    end;

    SendStr(GetBasicHeader(200));

    if bUseCompression and FRequestAcceptEncodingDeflate then begin


       OutputStream := TMemoryStream.Create;

       CompressionStream := TZCompressionStream.Create(OutputStream, zcMax);
       CompressionStream.CopyFrom(FIn, FIn.Size);
       CompressionStream.Free;

       OutputStream.Seek(0, soBeginning);


       if OutputStream.Size > FIn.Size then begin
          // la compression augmente la taille du fichier...
          OutputStream.Free;
          FIn.Seek(0, soBeginning);
          goto lSendFileNoCompression;
       end;

       FIn.Free;

       SendStr('Content-Length: ' + IntToStr(OutputStream.Size) + CRLF);
       SendStr('Content-Encoding: deflate' + CRLF);

       // envoi le CRLF supplémentaire
       SendStr(CRLF);


       SendStream(OutputStream);

       OutputStream.Free;

    end else begin

lSendFileNoCompression:
       SendStr('Content-Length: ' + IntToStr(FIn.Size) + CRLF);

       // envoi le CRLF supplémentaire
       SendStr(CRLF);

       SendStream(Fin);
       FIn.Free;
    end;

    // ferme la connexion
    CloseDelayed;
    FState := hcForceClose;

end;

procedure TTunnelHttpConnection.SendPageWeb(sDataPageWeb: string; hStatusCode: integer = 200);
var sHeader: string;
    CompressionStream: TZCompressionStream;
    InputStream, OutputStream: TMemoryStream;
    sEncoding: string;
begin


    if (sDataPageWeb = '') and (hStatusCode = 200) then
       // la page est vide lors de relocation par exemple (ou d'erreur)
       sDataPageWeb := 'Erreur';


    sEncoding := '';

    if (FRequestAcceptEncodingDeflate) and (length(sDataPageWeb) > 5) then begin
        InputStream := TMemoryStream.Create;
        InputStream.Write(sDataPageWeb[1], length(sDataPageWeb));
        InputStream.Seek(0, soBeginning);
        OutputStream := TMemoryStream.Create;

        CompressionStream := TZCompressionStream.Create(OutputStream, zcMax);
        CompressionStream.CopyFrom(InputStream, InputStream.Size);
        CompressionStream.Free;

        InputStream.Free;

        if length(sDataPageWeb) > OutputStream.Size then begin
           // compression utile
           sEncoding := 'deflate';

           SetLength(sDataPageWeb, OutputStream.Size);
           OutputStream.Seek(0, soBeginning);
           OutputStream.Read(sDataPageWeb[1], OutputStream.Size);
        end;

        OutputStream.Free;

    end;


    if ReponseContentType = '' then
       ReponseContentType := 'text/html';

    sHeader := GetBasicHeader(hStatusCode);


    // envoi l'header
    SendStr(sHeader);


    SendStr('Content-Length: ' + IntToStr(length(sDataPageWeb)) + CRLF);

    if sEncoding <> '' then begin
       SendStr('Content-Encoding: ' + sEncoding + CRLF);
    end;


    // envoi le CRLF supplémentaire
    SendStr(CRLF);

    try
       if length(sDataPageWeb) > 0 then begin
          // envoi le contenu
          SendStr(sDataPageWeb);
       end;


       if State = wsConnected then begin
          // ferme la connexion
          CloseDelayed;
       end;

    finally
       FState := hcForceClose;
    end;

end;


procedure TTunnelHttpConnection.MakeRedirection(Path: string);
begin
     AddHeaderLigne('Location: ' + Path);
     SendPageWeb('', 302);
end;


procedure TTunnelHttpConnection.MakeErreur(StatusCode: integer);
var sHeader, sMsg: string;
    sPageWeb: string;
begin

  case StatusCode of
      400: sMsg := 'Bad Request';
      401: sMsg := 'Unauthorized';
      402: sMsg := 'Payment Required';
      403: sMsg := 'Forbidden';
      404: sMsg := 'Not Found';
      405: sMsg := 'Method Not Allowed';
      406: sMsg := 'Not Acceptable';
      407: sMsg := 'Proxy Authentication Required';
      408: sMsg := 'Request Timeout';
      409: sMsg := 'Conflict';
      410: sMsg := 'Gone';
      411: sMsg := 'Length Required';
      412: sMsg := 'Precondition Failed';
      413: sMsg := 'Request Entity Too Large';
      414: sMsg := 'Request-URI Too Long';
      415: sMsg := 'Unsupported Media Type';
      416: sMsg := 'Requested Range Not Satisfiable';
      417: sMsg := 'Expectation Failed';

      500: sMsg := 'Internal Server Error';
  end;

    sPageWeb := 'Erreur ' + IntToStr(StatusCode) + ' - ' + sMsg;



    sHeader := FVersion + ' ' + IntToStr(StatusCode) + ' ' + sMsg + CRLF +
               'Server: Apache/1.3.28 (Unix) PHP/4.2.3' + CRLF +
               'Connection: close' + CRLF +
               'Accept-Ranges: bytes' + CRLF +
               'Content-Type: ' + ReponseContentType + CRLF +
               'Content-Length: ' + IntToStr(length(sPageWeb)) + CRLF;

    // envoi l'header
    SendStr(sHeader);

    // envoi le CRLF supplémentaire
    SendStr(CRLF);


    SendStr(sPageWeb);


    // ferme la connexion
    CloseDelayed;
    FState := hcForceClose;

end;

function TTunnelHttpConnection.GetBasicHeader(StatusCode: integer): string;
begin
(*
HTTP/1.1 200 OK
Date: Wed, 05 Nov 2003 10:46:04 GMT
Server: Apache/1.3.28 (Unix) PHP/4.2.3
Content-Location: CSS2-REC.en.html
Vary: negotiate,accept-language,accept-charset
TCN: choice
P3P: policyref=http://www.w3.org/2001/05/P3P/p3p.xml
Cache-Control: max-age=21600
Expires: Wed, 05 Nov 2003 16:46:04 GMT
Last-Modified: Tue, 12 May 1998 22:18:49 GMT
ETag: "3558cac9;36f99e2b"
Accept-Ranges: bytes
Content-Length: 10734
Connection: close
Content-Type: text/html; charset=utf-8
Content-Language: en
*)
    if ReponseContentType = '' then
       ReponseContentType := 'text/html';

    if StatusCode < 100 then
       StatusCode := 200;

    Result := FVersion + ' ' + IntToStr(StatusCode) + ' OK' + CRLF +
               'Server: Apache/1.3.28 (Unix) PHP/4.2.3' + CRLF +
               'Connection: close' + CRLF +
               'Accept-Ranges: bytes' + CRLF +
               'Content-Type: ' + ReponseContentType + CRLF +
               ReponseAdditionalHeader;


end;


constructor TTunnelHttpConnection.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);

    InitRequestInfos;
    FState := hcAttenteFirstLineHeader;

    FBuffer := '';
    SocketRelay := nil;
    MotorTemplate := nil;
end;

destructor TTunnelHttpConnection.Destroy;
begin

    if SocketRelay <> nil then begin
       SocketRelay.Free;
       SocketRelay := nil;
    end;

    inherited Destroy;
end;





procedure TTunnelHttpConnection.TriggerClientRequete;
begin
    FState := hcAttenteFirstLineHeader;


    if FRequestAcceptEncoding <> '' then begin
       FRequestAcceptEncoding := lowercase(FRequestAcceptEncoding);
       if pos('gzip', FRequestAcceptEncoding) > 0 then
          FRequestAcceptEncodingGZip    := true;

       if pos('deflate', FRequestAcceptEncoding) > 0 then
          FRequestAcceptEncodingDeflate    := true;

    end;




    if Assigned(kOnRequest) then begin
       // kOnRequest(Self);
       TraitementRequete;

    end else begin
       // on ferme la connexion
       Close;
       FState := hcForceClose;
    end;
end;

procedure TTunnelHttpConnection.TriggerOnHeaderLu;
begin
    if FRequestContentLength = 0 then begin
       // la requete est terminée
       TriggerClientRequete;

    end else begin
       // sinon on doit lire les données postées...
       // mais peut-être existent-elles déjà ?
       // on force l'évènement lOnClientDataAvailable
       lOnClientDataAvailable(Self, 0);
    end;
    

end;

procedure TTunnelHttpConnection.TraitementHeaderFromBuffer;
var Ligne, Key: string;
    xPos: integer;
begin

(*
GET /page.html HTTP/1.0
Host: example.com
Referer: http://example.com/
User-Agent: CERN-LineMode/2.15 libwww/2.17b3
*)

    repeat
        Ligne := sfcGetLigneUnixOrWin(FBuffer);

        if sfcGetLigneUnixOrWin_NoData then break;

        if Ligne = '' then begin
           // le reste correspond aux données postés ou à une autre requete
           TriggerOnHeaderLu;
           break;
        end;

        if FState = hcAttenteFirstLineHeader then begin
           // GET /page.html HTTP/1.0
           InitRequestInfos;

           FMethod      := sfcTokenGet(Ligne, 1, ' ');
           FPathRequest := sfcTokenGet(Ligne, 2, ' ');
           FVersion     := sfcTokenGet(Ligne, 3, ' ');

           if (SameText(FMethod, 'GET') = false) and (SameText(FMethod, 'POST') = false) then begin
              // requete invalide
              FState := hcForceClose;
              Close;
              exit;
           end;

           // on attend la fin de l'header maintenant
           FState := hcAttenteFinHeader;

        end else if FState = hcAttenteFinHeader then begin

           xPos := pos(':', Ligne);
           if xPos < 1 then begin
              // requete invalide
              FState := hcForceClose;
              Close;
              exit;
           end;

           Key := copy(Ligne, 1, xPos - 1);
           System.Delete(Ligne, 1, xPos + 1);

           if SameText(Key, 'host') then begin
              FRequestHost := Ligne;

           end else if SameText(Key, 'Accept-Encoding') then begin
              // Accept-Encoding: gzip, deflate
              FRequestAcceptEncoding := Ligne;


           end else if SameText(Key, 'Content-Length') then begin
              try
                 FRequestContentLength := StrToIntDef(Ligne, -1);
              except
                 FRequestContentLength := -1;
              end;



              if FRequestContentLength < 0 then begin
                 FState := hcForceClose;
                 Close;
                 exit;

              end else if FRequestContentLength > 0 then begin
                 // on doit télécharger les données postées
                 if SameText(FMethod, 'GET') then begin
                    // pas de données posté lors d'un GEt
                    FState := hcForceClose;
                    Close;
                    exit;
                 end;

                 if FRequestContentLength > 1024 then begin
                     MakeErreur(413);
                     exit;
                 end;


                 FState :=  hcAttenteFinDonneesPoste;
              end;

           end else if SameText(Key, 'Cookie') then begin
              FRequestCookies := Ligne;

           end;

        end;

    until false;

end;


procedure TTunnelHttpConnection.lOnClientDataAvailable(Sender: TObject; Error: Word);
var s: TTunnelHttpConnection;
    DataRecu: string;
begin

    s := TTunnelHttpConnection(Sender);

    if s.FState = hcForceClose then begin
       // vide le tampon
       DataRecu := s.ReceiveStr;
       s.Close;
       exit;
    end;


    FBuffer := FBuffer + s.ReceiveStr;


    if (s.FState = hcAttenteFinHeader) or
       (s.FState = hcAttenteFirstLineHeader) then begin


       s.TraitementHeaderFromBuffer;

    end else if s.FState = hcAttenteFinDonneesPoste then begin
       if length(FBuffer) >= FRequestContentLength then begin
          // données postées récupérées
          FPostedData := copy(FBuffer, 1, FRequestContentLength);
          System.Delete(FBuffer, 1, FRequestContentLength);

          TriggerClientRequete;
       end;

    end;





end;

end.
